home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gwuada_9.zip
/
STAT.C
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-27
|
18KB
|
663 lines
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#define GEN
#include "hdr.h"
#include "vars.h"
#include "gvars.h"
#include "ops.h"
#include "segment.h"
#include "setp.h"
#include "genp.h"
#include "exprp.h"
#include "namp.h"
#include "procp.h"
#include "maincasp.h"
#include "miscp.h"
#include "gmiscp.h"
#include "gutilp.h"
#include "statp.h"
static void select_move(Node, Symbol);
static Tuple sort_case(Tuple);
static int tcompar(Tuple *, Tuple *);
void compile_body(Node, Node, Node, int);
static int jump_false_code(Symbol);
static int jump_true_code(Symbol);
static Symbol jump_table_get(Tuple, int);
static Tuple jump_table_put(Tuple, int, Symbol);
/* Chapter 5: statements
* 5.2: Assignment statement
*/
void select_assign(Node var_node, Node expr_node, Symbol type_name)
/*;select_assign*/
{
Symbol var_name, expr_name;
var_name = N_UNQ(var_node);
expr_name = N_UNQ(expr_node);
if (is_simple_type(type_name) && is_simple_name(var_node)
&& !is_renaming(var_name) ) {
if ((is_simple_name(expr_node) && N_KIND(expr_node) != as_null
&& !is_renaming(expr_name))
|| (N_KIND(expr_node) == as_selector
|| N_KIND(expr_node) == as_index
|| N_KIND(expr_node) == as_all)) {
gen_address(expr_node);
gen_ks(I_INDIRECT_POP, kind_of(type_name), var_name);
}
else {
gen_value(expr_node);
gen_ks(I_POP, kind_of(type_name), var_name);
}
}
else {
gen_address(var_node);
select_move(expr_node, type_name);
}
}
static void select_move(Node node, Symbol type_name) /*;select_move*/
{
if (is_simple_type(type_name)) {
if ((N_KIND(node) != as_null
&& is_simple_name(node) && !is_renaming(N_UNQ(node)))
|| (N_KIND(node) == as_selector || N_KIND(node) == as_index
|| N_KIND(node) == as_all)) {
gen_address(node);
gen_k(I_INDIRECT_MOVE, kind_of(type_name));
}
else {
gen_value(node);
gen_k(I_MOVE, kind_of(type_name));
}
}
else {
if (is_array_type(type_name)) {
gen_value(node);
gen(I_ARRAY_MOVE);
}
else {
gen_value(node);
gen_s(I_RECORD_MOVE, type_name);
}
}
}
/* 5.4: Case statement */
Tuple make_case_table(Node cases_node) /*;make_case_table*/
{
/* Function : takes a set of alternatives, and produces a linear table
* suitable for jump table, of case ranges sorted in ascending
* order. Some optimisation is done, to merge contiguous
* ranges and to fill missing ranges with "others" case
* Input : case_node ::= {case_statements}
* case_statements ::= [choice_list, body]
* choice_list ::= { choice }
* choice ::= simple_choice | range_choice
* | others_choice
* simple_choice ::= [ value ]
* range_choice ::= [ subtype ]
* Output : [table, bodies, others_body]
* table ::= [ [ lower_bound, index ] ]
* - an extra pair is added with a "lower_bound" one step
* higher than necessary
* - "index" is an index in the tuple "bodies", and
* index = 0 means "others"
*/
Node case_statements_node, choice_list_node, body_node, choice_node,
lbd_node, ubd_node, others_body;
Tuple result, tup, bodies, triplets;
int index, a1, a2, a3, b1, b2, b3, lbd_int, ubd_int;
int empty;
Fortup ft1, ft2;
#ifdef TRACE
if (debug_flag)
gen_trace_node("MAKE_CASE_TABLE", cases_node);
#endif
/* 1. build a set of triples [lowerbound, upperbound, index] */
index = 0;
bodies = tup_new(0);
triplets = tup_new(0);
others_body = OPT_NODE;
FORTUP(case_statements_node = (Node), N_LIST(cases_node), ft1);
choice_list_node = N_AST1(case_statements_node);
body_node = N_AST2(case_statements_node);
index += 1;
empty = TRUE; /* may be we have an empty branch */
FORTUP(choice_node = (Node), N_LIST(choice_list_node), ft2);
switch (N_KIND(choice_node)) {
case (as_range):
lbd_node = N_AST1(choice_node);
ubd_node = N_AST2(choice_node);
lbd_int = get_ivalue_int(lbd_node);
ubd_int = get_ivalue_int(ubd_node);
if (lbd_int <= ubd_int) {
tup = tup_new(3);
tup[1] = (char *) lbd_int;
tup[2] = (char *) ubd_int;
tup[3] = (char *) index;
triplets = tup_with(triplets, (char *) tup);
empty = FALSE;
}
break;
case (as_others_choice):
others_body = body_node;
break;
default:
compiler_error( "Unknown kind of choice: ");
}
ENDFORTUP(ft2);
if (empty)
index -= 1;
else
bodies = tup_with(bodies, (char *) body_node);
ENDFORTUP(ft1);
result = tup_new(0);
if (tup_size(triplets) != 0) { /* We may have a completely empty case */
/* 2. sort the set of triples, giving a tuple */
triplets = sort_case(triplets);
/* 3. build the case table, filling gaps and merging adjacent cases */
tup = (Tuple) tup_fromb(triplets);
a1 = (int) tup[1];
a2 = (int) tup[2];
a3 = (int) tup[3];
while(tup_size(triplets) != 0) {
tup = (Tuple) tup_fromb(triplets);
b1 = (int) tup[1];
b2 = (int) tup[2];
b3 = (int) tup[3];
if (a2 != b1-1) { /* gap */
tup = tup_new(2);
tup[1] = (char *) a1;
tup[2] = (char *) a3;
result = tup_with(result, (char *) tup);
tup = tup_new(2);
tup[1] = (char *) (a2+1);
tup[2] = (char *) 0;
result = tup_with(result, (char *) tup);
a1 = b1;
a2 = b2;
a3 = b3;
}
else if (a3 == b3) { /* merge */
a2 = b2;
a3 = b3;
}
else {
tup = tup_new(2);
tup[1] = (char *) a1;
tup[2] = (char *) a3;
result = tup_with(result, (char *) tup);
a1 = b1;
a2 = b2;
a3 = b3;
}
}
tup = tup_new(2);
tup[1] = (char *) a1;
tup[2] = (char *) a3;
result = tup_with(result, (char *) tup);
tup = tup_new(2);
if (a2 != MAX_INTEGER) {
tup[1] = (char *) a2+1;
tup[2] = (char *) 0;
}
else {
tup[1] = (char *) 0; /* does not really matter */
tup[2] = (char *) a3;/* merge with the preceeding */
}
result = tup_with(result, (char *) tup);
}
tup = tup_new(3);
tup[1] = (char *) result;
tup[2] = (char *) bodies;
tup[3] = (char *) others_body;
return tup;
}
static Tuple sort_case(Tuple tuple_to_sort) /*;sort_case*/
{
/*
* Takes a set of case triples, and returns a tuple of those triple,
* sorted by ascending lower bounds. Quick sort algorithm.
* (sorry, this is not efficient, but was very easy to write)
*/
qsort((char *) &tuple_to_sort[1], tup_size(tuple_to_sort), sizeof (char *),
(int (*)(const void *, const void *))tcompar);
return tuple_to_sort;
}
static int tcompar(Tuple *ptup1, Tuple *ptup2) /*;tcompar*/
{
Tuple tup1, tup2;
int n1, n2;
tup1 = *ptup1;
tup2 = *ptup2;
/* called from sort_case to compare two elements in the case list */
n1 = (int) tup1[1];
n2 = (int) tup2[1];
if (n1 == n2) return 0;
else if (n1 < n2) return -1;
else return 1;
}
void gen_case(Tuple case_table, Tuple bodies_arg, Node others_body,int mem_unit)
/*;gen_case*/
{
/* Generates the code to select the right alternative and the bodies */
int index, lower_bound, i, n;
Node body_node;
Symbol end_case, jumpsym;
Tuple jump_table, tup;
Fortup ft1;
Tuple bodies;
bodies = tup_copy(bodies_arg); /* copy needed since used in tup_fromb */
end_case = new_unique_name("end_case");
gen_k(I_CASE, mem_unit);
/* The SETL jump_table map is represented as a 'tuple map' in C, with
* procedures jump_table_get() and jump_table_put() (defined below) used
* to retrieve and insert values in this map.
*/
jump_table = tup_new(0);
jump_table = jump_table_put(jump_table, 0, new_unique_name("case"));
gen_ks(I_CASE_TABLE, tup_size(case_table), jump_table_get(jump_table, 0) );
FORTUP(tup = (Tuple), case_table, ft1);
lower_bound = (int) tup[1];
index = (int) tup[2];
jumpsym = jump_table_get(jump_table, index);
if (jumpsym == (Symbol)0) { /* if no entry yet, make new one */
jumpsym = new_unique_name("case");
jump_table = jum